home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / repl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-13  |  46.3 KB  |  2,338 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include <fcntl.h>
  45. #include <errno.h>
  46. #include "_scm.h"
  47.  
  48.  
  49. unsigned char scm_upcase[CHAR_CODE_LIMIT];
  50. unsigned char scm_downcase[CHAR_CODE_LIMIT];
  51. unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
  52. unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  53.  
  54. extern int scm_verbose;
  55. #ifdef __STDC__
  56. void 
  57. scm_tables_prehistory (void)
  58. #else
  59. void 
  60. scm_tables_prehistory ()
  61. #endif
  62. {
  63.   int i;
  64.   for (i = 0; i < CHAR_CODE_LIMIT; i++)
  65.     scm_upcase[i] = scm_downcase[i] = i;
  66.   for (i = 0; i < sizeof scm_lowers / sizeof (char); i++)
  67.     {
  68.       scm_upcase[scm_lowers[i]] = scm_uppers[i];
  69.       scm_downcase[scm_uppers[i]] = scm_lowers[i];
  70.     }
  71.   scm_verbose = 1;        /* Here so that monitor info won't be */
  72.   /* printed while in scm_init_storage. (BOOM) */
  73. }
  74.  
  75. #ifdef EBCDIC
  76. char *scm_charnames[] =
  77. {
  78.   "nul","soh","stx","etx", "pf", "ht", "lc","del",
  79.    0   , 0   ,"smm", "vt", "ff", "cr", "so", "si",
  80.   "dle","dc1","dc2","dc3","res", "nl", "bs", "il",
  81.   "can", "em", "cc", 0   ,"ifs","igs","irs","ius",
  82.    "ds","sos", "fs", 0   ,"byp", "lf","eob","pre",
  83.    0   , 0   , "sm", 0   , 0   ,"enq","ack","bel",
  84.    0   , 0   ,"syn", 0   , "pn", "rs", "uc","eot",
  85.    0   , 0   , 0   , 0   ,"dc4","nak", 0   ,"sub",
  86.    "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
  87. char scm_charnums[] =
  88. "\000\001\002\003\004\005\006\007\
  89. \010\011\012\013\014\015\016\017\
  90. \020\021\022\023\024\025\026\027\
  91. \030\031\032\033\034\035\036\037\
  92. \040\041\042\043\044\045\046\047\
  93. \050\051\052\053\054\055\056\057\
  94. \060\061\062\063\064\065\066\067\
  95. \070\071\072\073\074\075\076\077\
  96.  \n\t\b\r\f\0";
  97. #endif /* def EBCDIC */
  98. #ifdef ASCII
  99. char *scm_charnames[] =
  100. {
  101.   "nul","soh","stx","etx","eot","enq","ack","bel",
  102.    "bs", "ht", "nl", "vt", "np", "cr", "so", "si",
  103.   "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
  104.   "can", "em","sub","esc", "fs", "gs", "rs", "us",
  105.   "space", "newline", "tab", "backspace", "return", "page", "null", "del"};
  106. char scm_charnums[] =
  107. "\000\001\002\003\004\005\006\007\
  108. \010\011\012\013\014\015\016\017\
  109. \020\021\022\023\024\025\026\027\
  110. \030\031\032\033\034\035\036\037\
  111.  \n\t\b\r\f\0\177";
  112. #endif /* def ASCII */
  113.  
  114.  
  115. /* Local functions needing declarations.
  116.  */
  117.  
  118. static SCM lreadr P ((SCM tok_buf, SCM port, int case_i));
  119. static SCM lreadparen P ((SCM tok_buf, SCM port, char *name, int case_i));
  120. static sizet read_token P ((int ic, SCM tok_buf, SCM port, int case_i,
  121.                 int weird));
  122.  
  123.  
  124. /* {Names of immediate symbols}
  125.  * 
  126.  * This table must agree with the declarations in scm.h: {Immediate Symbols}.
  127.  */
  128.  
  129. char *scm_isymnames[] =
  130. {
  131.   /* This table must agree with the declarations */
  132.   "#@and",
  133.   "#@begin",
  134.   "#@case",
  135.   "#@cond",
  136.   "#@do",
  137.   "#@if",
  138.   "#@lambda",
  139.   "#@let",
  140.   "#@let*",
  141.   "#@letrec",
  142.   "#@or",
  143.   "#@quote",
  144.   "#@set!",
  145.   "#@define",
  146. #if 0
  147.   "#@literal-variable-ref",
  148.   "#@literal-variable-set!",
  149. #endif
  150.   "#@apply",
  151.   "#@call-with-current-continuation",
  152.  
  153.  /* user visible ISYMS */
  154.  /* other keywords */
  155.  /* Flags */
  156.  
  157.   "#f",
  158.   "#t",
  159.   "#<undefined>",
  160.   "#<eof>",
  161.   "()",
  162.   "#<unspecified>"
  163. };
  164.  
  165. /* {Printing of Scheme Objects}
  166.  */
  167.  
  168. /* Print an integer.
  169.  */
  170. #ifdef __STDC__
  171. void 
  172. scm_intprint (long n, int radix, SCM port)
  173. #else
  174. void 
  175. scm_intprint (n, radix, port)
  176.      long n;
  177.      int radix;
  178.      SCM port;
  179. #endif
  180. {
  181.   char num_buf[INTBUFLEN];
  182.   scm_lfwrite (num_buf, (sizet) sizeof (char), scm_iint2str (n, radix, num_buf), port);
  183. }
  184.  
  185. /* Print an object of unrecognized type.
  186.  */
  187. #ifdef __STDC__
  188. void 
  189. scm_ipruk (char *hdr, SCM ptr, SCM port)
  190. #else
  191. void 
  192. scm_ipruk (hdr, ptr, port)
  193.      char *hdr;
  194.      SCM ptr;
  195.      SCM port;
  196. #endif
  197. {
  198.   scm_puts ("#<unknown-", port);
  199.   scm_puts (hdr, port);
  200.   if (CELLP (ptr))
  201.     {
  202.       scm_puts (" (0x", port);
  203.       scm_intprint (CAR (ptr), 16, port);
  204.       scm_puts (" . 0x", port);
  205.       scm_intprint (CDR (ptr), 16, port);
  206.       scm_puts (") @", port);
  207.     }
  208.   scm_puts (" 0x", port);
  209.   scm_intprint (ptr, 16, port);
  210.   scm_putc ('>', port);
  211. }
  212.  
  213. /* Print a list.
  214.  */
  215. #ifdef __STDC__
  216. void 
  217. scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
  218. #else
  219. void 
  220. scm_iprlist (hdr, exp, tlr, port, writing)
  221.      char *hdr;
  222.      SCM exp;
  223.      char tlr;
  224.      SCM port;
  225.      int writing;
  226. #endif
  227. {
  228.   scm_puts (hdr, port);
  229.   /* CHECK_INTS; */
  230.   scm_iprin1 (CAR (exp), port, writing);
  231.   exp = CDR (exp);
  232.   for (; NIMP (exp); exp = CDR (exp))
  233.     {
  234.       if (NECONSP (exp))
  235.     break;
  236.       scm_putc (' ', port);
  237.       /* CHECK_INTS; */
  238.       scm_iprin1 (CAR (exp), port, writing);
  239.     }
  240.   if (NNULLP (exp))
  241.     {
  242.       scm_puts (" . ", port);
  243.       scm_iprin1 (exp, port, writing);
  244.     }
  245.   scm_putc (tlr, port);
  246. }
  247.  
  248. /* Print generally.  Handles both write and display according to WRITING.
  249.  */
  250. #ifdef __STDC__
  251. void 
  252. scm_iprin1 (SCM exp, SCM port, int writing)
  253. #else
  254. void 
  255. scm_iprin1 (exp, port, writing)
  256.      SCM exp;
  257.      SCM port;
  258.      int writing;
  259. #endif
  260. {
  261.   register long i;
  262. taloop:
  263.   switch (7 & (int) exp)
  264.     {
  265.     case 2:
  266.     case 6:
  267.       scm_intprint (INUM (exp), 10, port);
  268.       break;
  269.     case 4:
  270.       if (ICHRP (exp))
  271.     {
  272.       i = ICHR (exp);
  273.       if (writing)
  274.         scm_puts ("#\\", port);
  275.       if (!writing)
  276.         scm_putc ((int) i, port);
  277.       else if ((i <= ' ') && scm_charnames[i])
  278.         scm_puts (scm_charnames[i], port);
  279. #ifndef EBCDIC
  280.       else if (i == '\177')
  281.         scm_puts (scm_charnames[(sizeof scm_charnames / sizeof (char *)) - 1], port);
  282. #endif /* ndef EBCDIC */
  283.       else if (i > '\177')
  284.         scm_intprint (i, 8, port);
  285.       else
  286.         scm_putc ((int) i, port);
  287.     }
  288.       else if (   IFLAGP (exp)
  289.            && (ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
  290.       scm_puts (ISYMCHARS (exp), port);
  291.       else if (ILOCP (exp))
  292.     {
  293.       scm_puts ("#@", port);
  294.       scm_intprint ((long) IFRAME (exp), 10, port);
  295.       scm_putc (ICDRP (exp) ? '-' : '+', port);
  296.       scm_intprint ((long) IDIST (exp), 10, port);
  297.     }
  298.       else
  299.     goto idef;
  300.       break;
  301.     case 1:
  302.       /* gloc */
  303.       scm_puts ("#@", port);
  304.       exp = CAR (exp - 1);
  305.       goto taloop;
  306.     default:
  307.     idef:
  308.       scm_ipruk ("immediate", exp, port);
  309.       break;
  310.     case 0:
  311.       switch (TYP7 (exp))
  312.     {
  313.     case tcs_cons_gloc:
  314.       if (CDR (CAR (exp) - 1L) == 0)
  315.         {
  316.           SCM name;
  317.           scm_lfwrite ("#<latte ",
  318.                (sizet) sizeof (char),
  319.                (sizet) 8,
  320.                port);
  321.           name = ((SCM *)(STRUCT_TYPE( exp)))[struct_i_name];
  322.           scm_lfwrite (CHARS (name),
  323.                (sizet) sizeof (char),
  324.                (sizet) LENGTH (name),
  325.                port);
  326.           scm_putc (' ', port);
  327.           scm_intprint(exp, 16, port);
  328.           scm_putc ('>', port);
  329.           break;
  330.         }
  331.     case tcs_cons_imcar:
  332.     case tcs_cons_nimcar:
  333.       scm_iprlist ("(", exp, ')', port, writing);
  334.       break;
  335.     case tcs_closures:
  336.       exp = CODE (exp);
  337.       scm_iprlist ("#<CLOSURE ", exp, '>', port, writing);
  338.       break;
  339.     case tc7_string:
  340.       if (writing)
  341.         {
  342.           scm_putc ('\"', port);
  343.           for (i = 0; i < LENGTH (exp); ++i)
  344.         switch (CHARS (exp)[i])
  345.           {
  346.           case '\"':
  347.           case '\\':
  348.             scm_putc ('\\', port);
  349.           default:
  350.             scm_putc (CHARS (exp)[i], port);
  351.           }
  352.           scm_putc ('\"', port);
  353.           break;
  354.         }
  355.       else
  356.         scm_lfwrite (CHARS (exp),
  357.              (sizet) sizeof (char),
  358.              (sizet) LENGTH (exp),
  359.              port);
  360.       break;
  361.     case tcs_symbols:
  362.       {
  363.         int pos;
  364.         int end;
  365.         int len;
  366.         char * str;
  367.         int weird;
  368.         int maybe_weird;
  369.         int mw_pos;
  370.  
  371.         len = LENGTH (exp);
  372.         str = CHARS (exp);
  373.         scm_remember (&exp);
  374.         pos = 0;
  375.         weird = 0;
  376.         maybe_weird = 0;
  377.  
  378.         for (end = pos; end < len; ++end)
  379.           switch (str[end])
  380.         {
  381. #ifdef BRACKETS_AS_PARENS
  382.         case '[':
  383.         case ']':
  384. #endif
  385.         case '(':
  386.         case ')':
  387.         case '\"':
  388.         case ';':
  389.         case WHITE_SPACES:
  390.         case LINE_INCREMENTORS:
  391.         weird_handler:
  392.           if (maybe_weird)
  393.             {
  394.               end = mw_pos;
  395.               maybe_weird = 0;
  396.             }
  397.           if (!weird)
  398.             {
  399.               scm_lfwrite ("#{", (sizet) sizeof(char), 2, port);
  400.               weird = 1;
  401.             }
  402.           if (pos < end)
  403.             {
  404.               scm_lfwrite (str + pos, sizeof (char), end - pos, port);
  405.             }
  406.           {
  407.             char buf[2];
  408.             buf[0] = '\\';
  409.             buf[1] = str[end];
  410.             scm_lfwrite (buf, (sizet) sizeof (char), 2, port);
  411.           }
  412.           pos = end + 1;
  413.           break;
  414.         case '\\':
  415.           if (weird)
  416.             goto weird_handler;
  417.           if (!maybe_weird)
  418.             {
  419.               maybe_weird = 1;
  420.               mw_pos = pos;
  421.             }
  422.           break;
  423.         case '}':
  424.         case '#':
  425.           if (weird)
  426.             goto weird_handler;
  427.           break;
  428.         default:
  429.           break;
  430.         }
  431.         if (pos < end)
  432.           scm_lfwrite (str + pos, (sizet) sizeof (char), end - pos, port);
  433.         if (weird)
  434.           scm_lfwrite ("}#", (sizet) sizeof (char), 2, port);
  435.         break;
  436.       }
  437.     case tc7_vector:
  438.       scm_puts ("#(", port);
  439.       for (i = 0; i + 1 < LENGTH (exp); ++i)
  440.         {
  441.           /* CHECK_INTS; */
  442.           scm_iprin1 (VELTS (exp)[i], port, writing);
  443.           scm_putc (' ', port);
  444.         }
  445.       if (i < LENGTH (exp))
  446.         {
  447.           /* CHECK_INTS; */
  448.           scm_iprin1 (VELTS (exp)[i], port, writing);
  449.         }
  450.       scm_putc (')', port);
  451.       break;
  452.     case tc7_lvector:
  453.       {
  454.         SCM result;
  455.         SCM hook;
  456.         hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
  457.         if (hook == BOOL_F)
  458.           {
  459.         scm_puts ("#<locked-vector ", port);
  460.         scm_intprint(CDR(exp), 16, port);
  461.         scm_puts (">", port);
  462.           }
  463.         else
  464.           {
  465.         result
  466.           = scm_apply (hook,
  467.                    scm_listify (exp, port, (writing ? BOOL_T : BOOL_F),
  468.                         SCM_UNDEFINED),
  469.                    EOL);
  470.         if (result == BOOL_F)
  471.           goto punk;
  472.           }
  473.         break;
  474.       }
  475.       break;
  476.     case tc7_bvect:
  477.     case tc7_ivect:
  478.     case tc7_uvect:
  479.     case tc7_fvect:
  480.     case tc7_dvect:
  481.     case tc7_cvect:
  482.       scm_raprin1 (exp, port, writing);
  483.       break;
  484.     case tcs_subrs:
  485.       scm_puts ("#<primitive-procedure ", port);
  486.       scm_puts (CHARS (SNAME (exp)), port);
  487.       scm_putc ('>', port);
  488.       break;
  489. #ifdef CCLO
  490.     case tc7_cclo:
  491.       scm_puts ("#<compiled-closure ", port);
  492.       scm_iprin1 (CCLO_SUBR (exp), port, writing);
  493.       scm_putc ('>', port);
  494.       break;
  495. #endif
  496.     case tc7_contin:
  497.       scm_puts ("#<continuation ", port);
  498.       scm_intprint (LENGTH (exp), 10, port);
  499.       scm_puts (" @ ", port);
  500.       scm_intprint ((long) CHARS (exp), 16, port);
  501.       scm_putc ('>', port);
  502.       break;
  503.     case tc7_port:
  504.       i = PTOBNUM (exp);
  505.       if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
  506.         break;
  507.       goto punk;
  508.     case tc7_smob:
  509.       i = SMOBNUM (exp);
  510.       if (i < scm_numsmob && scm_smobs[i].print
  511.           && (scm_smobs[i].print) (exp, port, writing))
  512.         break;
  513.       goto punk;
  514.     default:
  515.     punk:scm_ipruk ("type", exp, port);
  516.     }
  517.     }
  518. }
  519.  
  520. /* Various I/O primitives, leading up to READ
  521.  */
  522.  
  523. #ifdef __IBMC__
  524. # define MSDOS
  525. #endif
  526. #ifdef MSDOS
  527. # ifndef GO32
  528. #  include <io.h>
  529. #  include <conio.h>
  530. #ifdef __STDC__
  531. static int 
  532. input_waiting (FILE *f)
  533. #else
  534. static int 
  535. input_waiting (f)
  536.      FILE *f;
  537. #endif
  538. {
  539.   if (feof (f))
  540.     return 1;
  541.   if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin))))
  542.     return kbhit ();
  543.   return -1;
  544. }
  545. # endif
  546. #else
  547. # ifdef _DCC
  548. #  include <ioctl.h>
  549. # else
  550. #  ifndef AMIGA
  551. #   ifndef vms
  552. #    ifdef MWC
  553. #     include <sys/io.h>
  554. #    else
  555. #     ifndef THINK_C
  556. #      ifndef ARM_ULIB
  557. #       include <sys/ioctl.h>
  558. #      endif
  559. #     endif
  560. #    endif
  561. #   endif
  562. #  endif
  563. # endif
  564.  
  565.  
  566. #ifdef __STDC__
  567. static int
  568. input_waiting(FILE *f)
  569. #else
  570. static int
  571. input_waiting(f)
  572.      FILE *f;
  573. #endif
  574. {
  575. # ifdef FIONREAD
  576.   long remir;
  577.   if (feof(f)) return 1;
  578.   ioctl(fileno(f), FIONREAD, &remir);
  579.   return remir;
  580. # else
  581.   return -1;
  582. # endif
  583. }
  584. #endif
  585.  
  586. /* perhaps should undefine MSDOS from __IBMC__ here */
  587. #ifndef GO32
  588. PROC (s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p);
  589. #ifdef __STDC__
  590. SCM 
  591. scm_char_ready_p (SCM port)
  592. #else
  593. SCM 
  594. scm_char_ready_p (port)
  595.      SCM port;
  596. #endif
  597. {
  598.   if (UNBNDP (port))
  599.     port = cur_inp;
  600.   else
  601.     ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_char_ready_p);
  602.   if (CRDYP (port) || !FPORTP (port))
  603.     return BOOL_T;
  604.   return input_waiting (STREAM (port)) ? BOOL_T : BOOL_F;
  605. }
  606. #endif
  607.  
  608. PROC (s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p);
  609. #ifdef __STDC__
  610. SCM 
  611. scm_eof_object_p (SCM x)
  612. #else
  613. SCM 
  614. scm_eof_object_p (x)
  615.      SCM x;
  616. #endif
  617. {
  618.   return (EOF_VAL == x) ? BOOL_T : BOOL_F;
  619. }
  620.  
  621. /* internal SCM call */
  622. #ifdef __STDC__
  623. void 
  624. scm_fflush (SCM port)
  625. #else
  626. void 
  627. scm_fflush (port)
  628.      SCM port;
  629. #endif
  630. {
  631.   sizet i = PTOBNUM (port);
  632.   (scm_ptobs[i].fflush) (STREAM (port));
  633. }
  634.  
  635. PROC (s_force_output, "force-output", 0, 1, 0, scm_force_output);
  636. #ifdef __STDC__
  637. SCM 
  638. scm_force_output (SCM port)
  639. #else
  640. SCM 
  641. scm_force_output (port)
  642.      SCM port;
  643. #endif
  644. {
  645.   if (UNBNDP (port))
  646.  port = cur_outp;
  647.   else
  648.     ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, s_force_output);
  649.   {
  650.     sizet i = PTOBNUM (port);
  651.     SYSCALL ((scm_ptobs[i].fflush) (STREAM (port)));
  652.     return UNSPECIFIED;
  653.   }
  654. }
  655.  
  656. PROC (s_write, "write", 1, 1, 0, scm_write);
  657. #ifdef __STDC__
  658. SCM 
  659. scm_write (SCM obj, SCM port)
  660. #else
  661. SCM 
  662. scm_write (obj, port)
  663.      SCM obj;
  664.      SCM port;
  665. #endif
  666. {
  667.   if (UNBNDP (port))
  668.     port = cur_outp;
  669.   else
  670.     ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG2, s_write);
  671.   scm_iprin1 (obj, port, 1);
  672. #ifdef HAVE_PIPE
  673. # ifdef EPIPE
  674.   if (EPIPE == errno)
  675.     scm_close_port (port);
  676. # endif
  677. #endif
  678.   return UNSPECIFIED;
  679. }
  680.  
  681.  
  682. PROC (s_display, "display", 1, 1, 0, scm_display);
  683. #ifdef __STDC__
  684. SCM 
  685. scm_display (SCM obj, SCM port)
  686. #else
  687. SCM 
  688. scm_display (obj, port)
  689.      SCM obj;
  690.      SCM port;
  691. #endif
  692. {
  693.   if (UNBNDP (port))
  694.     port = cur_outp;
  695.   else
  696.     ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG2, s_display);
  697.   scm_iprin1 (obj, port, 0);
  698. #ifdef HAVE_PIPE
  699. # ifdef EPIPE
  700.   if (EPIPE == errno)
  701.     scm_close_port (port);
  702. # endif
  703. #endif
  704.   return UNSPECIFIED;
  705. }
  706.  
  707. PROC (s_newline, "newline", 0, 1, 0, scm_newline);
  708. #ifdef __STDC__
  709. SCM
  710. scm_newline(SCM port)
  711. #else
  712. SCM 
  713. scm_newline (port)
  714.      SCM port;
  715. #endif
  716. {
  717.   if (UNBNDP (port))
  718.  port = cur_outp;
  719.   else
  720.     ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, s_newline);
  721.   scm_putc ('\n', port);
  722. #ifdef HAVE_PIPE
  723. # ifdef EPIPE
  724.   if (EPIPE == errno)
  725.     scm_close_port (port);
  726.   else
  727. # endif
  728. #endif
  729.   if (port == cur_outp)
  730.     scm_fflush (port);
  731.   return UNSPECIFIED;
  732. }
  733.  
  734. PROC (s_write_char, "write-char", 1, 1, 0, scm_write_char);
  735. #ifdef __STDC__
  736. SCM 
  737. scm_write_char (SCM chr, SCM port)
  738. #else
  739. SCM 
  740. scm_write_char (chr, port)
  741.      SCM chr;
  742.      SCM port;
  743. #endif
  744. {
  745.   if (UNBNDP (port))
  746.  port = cur_outp;
  747.   else
  748.     ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG2, s_write_char);
  749.   ASSERT (ICHRP (chr), chr, ARG1, s_write_char);
  750.   scm_putc ((int) ICHR (chr), port);
  751. #ifdef HAVE_PIPE
  752. # ifdef EPIPE
  753.   if (EPIPE == errno)
  754.     scm_close_port (port);
  755. # endif
  756. #endif
  757.   return UNSPECIFIED;
  758. }
  759.  
  760. FILE *scm_trans = 0;
  761. #ifdef __STDC__
  762. SCM 
  763. scm_trans_on (SCM fil)
  764. #else
  765. SCM 
  766. scm_trans_on (fil)
  767.      SCM fil;
  768. #endif
  769. {
  770.   transcript = scm_open_file (fil,
  771.                   scm_makfromstr ("w", (sizet) sizeof (char), 0));
  772.   if (FALSEP (transcript))
  773.     scm_trans = 0;
  774.   else
  775.     scm_trans = STREAM (transcript);
  776.   return UNSPECIFIED;
  777. }
  778.  
  779. #ifdef __STDC__
  780. SCM 
  781. scm_trans_off (void)
  782. #else
  783. SCM 
  784. scm_trans_off ()
  785. #endif
  786. {
  787.   if (!FALSEP (transcript))
  788.     scm_close_port (transcript);
  789.   transcript = BOOL_F;
  790.   scm_trans = 0;
  791.   return UNSPECIFIED;
  792. }
  793.  
  794. #ifdef __STDC__
  795. void 
  796. scm_putc (int c, SCM port)
  797. #else
  798. void 
  799. scm_putc (c, port)
  800.      int c;
  801.      SCM port;
  802. #endif
  803. {
  804.   sizet i = PTOBNUM (port);
  805.   SYSCALL ((scm_ptobs[i].fputc) (c, STREAM (port)));
  806.   if (scm_trans && (port == def_outp || port == cur_errp))
  807.     SYSCALL (fputc (c, scm_trans));
  808. }
  809.  
  810. #ifdef __STDC__
  811. void 
  812. scm_puts (char *s, SCM port)
  813. #else
  814. void 
  815. scm_puts (s, port)
  816.      char *s;
  817.      SCM port;
  818. #endif
  819. {
  820.   sizet i = PTOBNUM (port);
  821.   SYSCALL ((scm_ptobs[i].fputs) (s, STREAM (port)));
  822.   if (scm_trans && (port == def_outp || port == cur_errp))
  823.     SYSCALL (fputs (s, scm_trans));
  824. }
  825.  
  826. #ifdef __STDC__
  827. int 
  828. scm_lfwrite (char *ptr, sizet size, sizet nitems, SCM port)
  829. #else
  830. int 
  831. scm_lfwrite (ptr, size, nitems, port)
  832.      char *ptr;
  833.      sizet size;
  834.      sizet nitems;
  835.      SCM port;
  836. #endif
  837. {
  838.   int ret;
  839.   sizet i = PTOBNUM (port);
  840.   SYSCALL (ret = (scm_ptobs[i].fwrite(ptr, size, nitems, STREAM (port))));
  841.   if (scm_trans && (port == def_outp || port == cur_errp))
  842.     SYSCALL (fwrite (ptr, size, nitems, scm_trans));
  843.   return ret;
  844. }
  845.  
  846. #ifdef __STDC__
  847. int 
  848. scm_lgetc (SCM port)
  849. #else
  850. int 
  851. scm_lgetc (port)
  852.      SCM port;
  853. #endif
  854. {
  855.   FILE *f;
  856.   int c;
  857.   sizet i;
  858.   /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */
  859.   if (CRDYP (port))
  860.     {
  861.       c = CGETUN (port);
  862.       CLRDY (port);        /* Clear ungetted char */
  863.       return c;
  864.     }
  865.   f = STREAM (port);
  866.   i = PTOBNUM (port);
  867. #ifdef linux
  868.   c = (scm_ptobs[i].fgetc) (f);
  869. #else
  870.   SYSCALL (c = (scm_ptobs[i].fgetc) (f));
  871. #endif
  872.   if (scm_trans && (f == stdin))
  873.     SYSCALL (fputc (c, scm_trans));
  874.   return c;
  875. }
  876.  
  877. #ifdef __STDC__
  878. void 
  879. scm_lungetc (int c, SCM port)
  880. #else
  881. void 
  882. scm_lungetc (c, port)
  883.      int c;
  884.      SCM port;
  885. #endif
  886. {
  887. /*    ASSERT(!CRDYP(port), port, ARG2, "too many scm_lungetc");*/
  888.   CUNGET (c, port);
  889. }
  890.  
  891.  
  892.  
  893. PROC (s_read_char, "read-char", 0, 1, 0, scm_read_char);
  894. #ifdef __STDC__
  895. SCM 
  896. scm_read_char (SCM port)
  897. #else
  898. SCM 
  899. scm_read_char (port)
  900.      SCM port;
  901. #endif
  902. {
  903.   int c;
  904.   if (UNBNDP (port))
  905.  port = cur_inp;
  906.   else
  907.     ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_read_char);
  908.   c = scm_lgetc (port);
  909.   if (EOF == c)
  910.     return EOF_VAL;
  911.   return MAKICHR (c);
  912. }
  913.  
  914.  
  915. PROC (s_peek_char, "peek-char", 0, 1, 0, scm_peek_char);
  916. #ifdef __STDC__
  917. SCM 
  918. scm_peek_char (SCM port)
  919. #else
  920. SCM 
  921. scm_peek_char (port)
  922.      SCM port;
  923. #endif
  924. {
  925.   int c;
  926.   if (UNBNDP (port))
  927.     port = cur_inp;
  928.   else
  929.     ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_peek_char);
  930.   c = scm_lgetc (port);
  931.   if (EOF == c)
  932.     return EOF_VAL;
  933.   scm_lungetc (c, port);
  934.   return MAKICHR (c);
  935. }
  936.  
  937.  
  938. #ifdef __STDC__
  939. char *
  940. scm_grow_tok_buf (SCM tok_buf)
  941. #else
  942. char *
  943. scm_grow_tok_buf (tok_buf)
  944.      SCM tok_buf;
  945. #endif
  946. {
  947.   sizet len = LENGTH (tok_buf);
  948.   len += len / 2;
  949.   scm_resizuve (tok_buf, (SCM) MAKINUM (len));
  950.   return CHARS (tok_buf);
  951. }
  952.  
  953. static scm_cell scm_tmp_loadpath = {(SCM) BOOL_F, (SCM) EOL};
  954. SCM *scm_loc_loadpath = (SCM *) & scm_tmp_loadpath;
  955. SCM loadport = SCM_UNDEFINED;
  956. long scm_linum = 1;
  957.  
  958.  
  959. static char s_eofin[] = "end of file in ";
  960. #ifdef __STDC__
  961. static int 
  962. flush_ws (SCM port, char *eoferr)
  963. #else
  964. static int 
  965. flush_ws (port, eoferr)
  966.      SCM port;
  967.      char *eoferr;
  968. #endif
  969. {
  970.   register int c;
  971.   while (1)
  972.     switch (c = scm_lgetc (port))
  973.       {
  974.       case EOF:
  975.       goteof:
  976.     if (eoferr)
  977.       scm_wta (SCM_UNDEFINED, s_eofin, eoferr);
  978.     return c;
  979.       case ';':
  980.       lp:
  981.     switch (c = scm_lgetc (port))
  982.       {
  983.       case EOF:
  984.         goto goteof;
  985.       default:
  986.         goto lp;
  987.       case LINE_INCREMENTORS:
  988.         break;
  989.       }
  990.       case LINE_INCREMENTORS:
  991.     if (port==loadport) scm_linum++;
  992.       case WHITE_SPACES:
  993.     break;
  994.       default:
  995.     return c;
  996.       }
  997. }
  998.  
  999. #ifdef GUILE
  1000. static int default_case_i = 0;
  1001. #else 
  1002. static int default_case_i = 1;
  1003. #endif
  1004.  
  1005. PROC (s_read, "read", 0, 2, 0, scm_read);
  1006. #ifdef __STDC__
  1007. SCM 
  1008. scm_read (SCM port, SCM casep)
  1009. #else
  1010. SCM 
  1011. scm_read (port, casep)
  1012.      SCM port;
  1013.      SCM casep;
  1014. #endif
  1015. {
  1016.   int c;
  1017.   SCM tok_buf;
  1018.   int case_i;
  1019.  
  1020.   if (UNBNDP (port))
  1021.     port = cur_inp;
  1022.   else
  1023.     ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_read);
  1024.  
  1025.   case_i = (UNBNDP (casep)
  1026.         ? default_case_i
  1027.         : (casep == BOOL_F));
  1028.  
  1029.   do
  1030.     {
  1031.       c = flush_ws (port, (char *) NULL);
  1032.       if (EOF == c)
  1033.     return EOF_VAL;
  1034.       scm_lungetc (c, port);
  1035.       tok_buf = scm_makstr (30L, 0);
  1036.     }
  1037.   while (EOF_VAL == (tok_buf = lreadr (tok_buf, port, case_i)));
  1038.   return tok_buf;
  1039. }
  1040.  
  1041. #ifdef __STDC__
  1042. static int
  1043. casei_streq (char * s1, char * s2)
  1044. #else
  1045. static int
  1046. casei_streq (s1, s2)
  1047.      char * s1;
  1048.      char * s2;
  1049. #endif
  1050. {
  1051.   while (*s1 && *s2)
  1052.     if (scm_downcase[(int)*s1] != scm_downcase[(int)*s2])
  1053.       return 0;
  1054.     else
  1055.       {
  1056.     ++s1;
  1057.     ++s2;
  1058.       }
  1059.   return !(*s1 || *s2);
  1060. }
  1061.  
  1062.  
  1063. static char s_list[]="list";
  1064. static char s_unknown_sharp[] = "unknown # object";
  1065. #ifdef __STDC__
  1066. static SCM 
  1067. lreadr (SCM tok_buf, SCM port, int case_i)
  1068. #else
  1069. static SCM 
  1070. lreadr (tok_buf, port, case_i)
  1071.      SCM tok_buf;
  1072.      SCM port;
  1073.      int case_i;
  1074. #endif
  1075. {
  1076.   int c;
  1077.   sizet j;
  1078.   SCM p;
  1079. tryagain:
  1080.   c = flush_ws (port, s_read);
  1081.   switch (c)
  1082.     {
  1083. /*    case EOF: return EOF_VAL;*/
  1084. #ifdef BRACKETS_AS_PARENS
  1085.     case '[':
  1086. #endif
  1087.     case '(':
  1088.       return lreadparen (tok_buf, port, s_list, case_i);
  1089. #ifdef BRACKETS_AS_PARENS
  1090.     case ']':
  1091. #endif
  1092.     case ')':
  1093.       scm_warn ("unexpected \")\"", "");
  1094.       goto tryagain;
  1095.     case '\'':
  1096.       return scm_cons2 (scm_i_quote, lreadr (tok_buf, port, case_i), EOL);
  1097.     case '`':
  1098.       return scm_cons2 (scm_i_quasiquote, lreadr (tok_buf, port, case_i), EOL);
  1099.     case ',':
  1100.       c = scm_lgetc (port);
  1101.       if ('@' == c)
  1102.     p = scm_i_uq_splicing;
  1103.       else
  1104.     {
  1105.       scm_lungetc (c, port);
  1106.       p = scm_i_unquote;
  1107.     }
  1108.       return scm_cons2 (p, lreadr (tok_buf, port, case_i), EOL);
  1109.     case '#':
  1110.       c = scm_lgetc (port);
  1111.       switch (c)
  1112.     {
  1113. #ifdef BRACKETS_AS_PARENS
  1114.     case '[':
  1115. #endif
  1116.     case '(':
  1117.       p = lreadparen (tok_buf, port, "vector", case_i);
  1118.       return NULLP (p) ? nullvect : scm_vector (p);
  1119.     case 't':
  1120.     case 'T':
  1121.       return BOOL_T;
  1122.     case 'f':
  1123.     case 'F':
  1124.       return BOOL_F;
  1125.     case 'b':
  1126.     case 'B':
  1127.     case 'o':
  1128.     case 'O':
  1129.     case 'd':
  1130.     case 'D':
  1131.     case 'x':
  1132.     case 'X':
  1133.     case 'i':
  1134.     case 'I':
  1135.     case 'e':
  1136.     case 'E':
  1137.       scm_lungetc (c, port);
  1138.       c = '#';
  1139.       goto num;
  1140.     case '*':
  1141.       j = read_token (c, tok_buf, port, case_i, 0);
  1142.       p = scm_istr2bve (CHARS (tok_buf) + 1, (long) (j - 1));
  1143.       if (NFALSEP (p))
  1144.         return p;
  1145.       else
  1146.         goto unkshrp;
  1147.     case '{':
  1148.       j = read_token (c, tok_buf, port, case_i, 1);
  1149.       p = scm_intern (CHARS (tok_buf), j);
  1150.       return CAR (p);
  1151.     case '\\':
  1152.       c = scm_lgetc (port);
  1153.       j = read_token (c, tok_buf, port, case_i, 0);
  1154.       if (j == 1)
  1155.         return MAKICHR (c);
  1156.       if (c >= '0' && c < '8')
  1157.         {
  1158.           p = scm_istr2int (CHARS (tok_buf), (long) j, 8);
  1159.           if (NFALSEP (p))
  1160.         return MAKICHR (INUM (p));
  1161.         }
  1162.       for (c = 0; c < sizeof scm_charnames / sizeof (char *); c++)
  1163.         if (scm_charnames[c]
  1164.         && (casei_streq (scm_charnames[c], CHARS (tok_buf))))
  1165.           return MAKICHR (scm_charnums[c]);
  1166.       scm_wta (SCM_UNDEFINED, "unknown # object: #\\", CHARS (tok_buf));
  1167.     case '|':
  1168.       j = 1;        /* here j is the comment nesting depth */
  1169.     lp:c = scm_lgetc (port);
  1170.     lpc:switch (c)
  1171.         {
  1172.         case EOF:
  1173.           scm_wta (SCM_UNDEFINED, s_eofin, "balanced comment");
  1174.         case LINE_INCREMENTORS:
  1175.           if (port==loadport) scm_linum++;
  1176.         default:
  1177.           goto lp;
  1178.         case '|':
  1179.           if ('#' != (c = scm_lgetc (port)))
  1180.         goto lpc;
  1181.           if (--j)
  1182.         goto lp;
  1183.           break;
  1184.         case '#':
  1185.           if ('|' != (c = scm_lgetc (port)))
  1186.         goto lpc;
  1187.           ++j;
  1188.           goto lp;
  1189.         }
  1190.       goto tryagain;
  1191.     case '.':
  1192.       p = lreadr (tok_buf, port, case_i);
  1193.       return scm_eval_x (p);
  1194.     default:
  1195.     callshrp:
  1196.       p = CDR (scm_intern ("read:sharp", (sizeof "read:sharp") - 1));
  1197.       if (NIMP (p))
  1198.         {
  1199.           p = scm_apply (p, MAKICHR (c), scm_acons (port, EOL, EOL));
  1200.           if (UNSPECIFIED == p)
  1201.         goto tryagain;
  1202.           return p;
  1203.         }
  1204.     unkshrp:scm_wta ((SCM) MAKICHR (c), s_unknown_sharp, "");
  1205.     }
  1206.     case '\"':
  1207.       j = 0;
  1208.       while ('\"' != (c = scm_lgetc (port)))
  1209.     {
  1210.       ASSERT (EOF != c, SCM_UNDEFINED, s_eofin, "string");
  1211.       if (j + 1 >= LENGTH (tok_buf))
  1212.         scm_grow_tok_buf (tok_buf);
  1213.       if (c == '\\')
  1214.         switch (c = scm_lgetc (port))
  1215.           {
  1216.           case '\n':
  1217.         continue;
  1218.           case '0':
  1219.         c = '\0';
  1220.         break;
  1221.           case 'f':
  1222.         c = '\f';
  1223.         break;
  1224.           case 'n':
  1225.         c = '\n';
  1226.         break;
  1227.           case 'r':
  1228.         c = '\r';
  1229.         break;
  1230.           case 't':
  1231.         c = '\t';
  1232.         break;
  1233.           case 'a':
  1234.         c = '\007';
  1235.         break;
  1236.           case 'v':
  1237.         c = '\v';
  1238.         break;
  1239.           }
  1240.       CHARS (tok_buf)[j] = c;
  1241.       ++j;
  1242.     }
  1243.       if (j == 0)
  1244.     return nullstr;
  1245.       CHARS (tok_buf)[j] = 0;
  1246.       return scm_makfromstr (CHARS (tok_buf), j, 0);
  1247.     case DIGITS:
  1248.     case '.':
  1249.     case '-':
  1250.     case '+':
  1251.     num:
  1252.       j = read_token (c, tok_buf, port, case_i, 0);
  1253.       p = scm_istring2number (CHARS (tok_buf), (long) j, 10L);
  1254.       if (NFALSEP (p))
  1255.  return p;
  1256.       if (c == '#')
  1257.     {
  1258.       if ((j == 2) && (scm_lgetc (port) == '('))
  1259.         {
  1260.           scm_lungetc ('(', port);
  1261.           c = CHARS (tok_buf)[1];
  1262.           goto callshrp;
  1263.         }
  1264.       scm_wta (SCM_UNDEFINED, s_unknown_sharp, CHARS (tok_buf));
  1265.     }
  1266.       goto tok;
  1267.     case ':':
  1268.       j = read_token ('-', tok_buf, port, case_i, 0);
  1269.       p = scm_intern (CHARS (tok_buf), j);
  1270.       return scm_make_keyword (CAR (p));
  1271.     default:
  1272.       j = read_token (c, tok_buf, port, case_i, 0);
  1273.     tok:
  1274.       p = scm_intern (CHARS (tok_buf), j);
  1275.       return CAR (p);
  1276.     }
  1277. }
  1278.  
  1279. #ifdef _UNICOS
  1280. _Pragma ("noopt");        /* # pragma _CRI noopt */
  1281. #endif
  1282. #ifdef __STDC__
  1283. static sizet 
  1284. read_token (int ic, SCM tok_buf, SCM port, int case_i, int weird)
  1285. #else
  1286. static sizet 
  1287. read_token (ic, tok_buf, port, case_i, weird)
  1288.      int ic;
  1289.      SCM tok_buf;
  1290.      SCM port;
  1291.      int case_i;
  1292.      int weird;
  1293. #endif
  1294. {
  1295.   register sizet j;
  1296.   register int c;
  1297.   register char *p;
  1298.  
  1299.   c = ic;
  1300.   p = CHARS (tok_buf);
  1301.  
  1302.   if (!weird)
  1303.     {
  1304.       p[0] = (case_i ? scm_downcase[c] : c);
  1305.       j = 1;
  1306.     }
  1307.   else
  1308.     j = 0;
  1309.  
  1310.   while (1)
  1311.     {
  1312.       if (j + 1 >= LENGTH (tok_buf))
  1313.     p = scm_grow_tok_buf (tok_buf);
  1314.       c = scm_lgetc (port);
  1315.       switch (c)
  1316.     {
  1317. #ifdef BRACKETS_AS_PARENS
  1318.     case '[':
  1319.     case ']':
  1320. #endif
  1321.     case '(':
  1322.     case ')':
  1323.     case '\"':
  1324.     case ';':
  1325.     case WHITE_SPACES:
  1326.     case LINE_INCREMENTORS:
  1327.       if (weird)
  1328.         goto default_case;
  1329.  
  1330.       scm_lungetc (c, port);
  1331.     case EOF:
  1332.     eof_case:
  1333.       p[j] = 0;
  1334.       return j;
  1335.     case '\\':
  1336.       if (!weird)
  1337.         goto default_case;
  1338.       else
  1339.         {
  1340.           c = scm_lgetc (port);
  1341.           if (c == EOF)
  1342.         goto eof_case;
  1343.           else
  1344.         goto default_case;
  1345.         }
  1346.     case '}':
  1347.       if (!weird)
  1348.         goto default_case;
  1349.  
  1350.       c = scm_lgetc (port);
  1351.       if (c == '#')
  1352.         {
  1353.           p[j] = 0;
  1354.           return j;
  1355.         }
  1356.       else
  1357.         {
  1358.           scm_lungetc (c, port);
  1359.           c = '}';
  1360.           goto default_case;
  1361.         }
  1362.  
  1363.     default:
  1364.     default_case:
  1365.       p[j++] = (case_i ? scm_downcase[c] : c);
  1366.     }
  1367.     }
  1368. }
  1369. #ifdef _UNICOS
  1370. _Pragma ("opt");        /* # pragma _CRI opt */
  1371. #endif
  1372.  
  1373. #ifdef __STDC__
  1374. static SCM 
  1375. lreadparen (SCM tok_buf, SCM port, char *name, int case_i)
  1376. #else
  1377. static SCM 
  1378. lreadparen (tok_buf, port, name, case_i)
  1379.      SCM tok_buf;
  1380.      SCM port;
  1381.      char *name;
  1382.      int case_i;
  1383. #endif
  1384. {
  1385.   SCM tmp, tl, ans;
  1386.   int c = flush_ws (port, name);
  1387.   if (')' == c
  1388. #ifdef BRACKETS_AS_PARENS
  1389.       || ']' == c
  1390. #endif
  1391.     )
  1392.     return EOL;
  1393.   scm_lungetc (c, port);
  1394.   if (scm_i_dot == (tmp = lreadr (tok_buf, port, case_i)))
  1395.     {
  1396.       ans = lreadr (tok_buf, port, case_i);
  1397.     closeit:
  1398.       if (')' != (c = flush_ws (port, name))
  1399. #ifdef BRACKETS_AS_PARENS
  1400.       && ']' != c
  1401. #endif
  1402.     )
  1403.     scm_wta (SCM_UNDEFINED, "missing close paren", "");
  1404.       return ans;
  1405.     }
  1406.   ans = tl = scm_cons (tmp, EOL);
  1407.   while (')' != (c = flush_ws (port, name))
  1408. #ifdef BRACKETS_AS_PARENS
  1409.      && ']' != c
  1410. #endif
  1411.     )
  1412.     {
  1413.       scm_lungetc (c, port);
  1414.       if (scm_i_dot == (tmp = lreadr (tok_buf, port, case_i)))
  1415.     {
  1416.       CDR (tl) = lreadr (tok_buf, port, case_i);
  1417.       goto closeit;
  1418.     }
  1419.       tl = (CDR (tl) = scm_cons (tmp, EOL));
  1420.     }
  1421.   return ans;
  1422. }
  1423.  
  1424. /* {Loading from source files.}
  1425.  */
  1426.  
  1427.  
  1428.  
  1429. static char s_load[]="load";
  1430.  
  1431. PROC (s_try_load, "try-load", 1, 0, 0, scm_try_load);
  1432. #ifdef __STDC__
  1433. SCM 
  1434. scm_try_load (SCM filename)
  1435. #else
  1436. SCM 
  1437. scm_try_load (filename)
  1438.      SCM filename;
  1439. #endif
  1440. {
  1441.   ASSERT (NIMP (filename) && STRINGP (filename), filename, ARG1, s_load);
  1442.   {
  1443.     SCM oloadpath = *scm_loc_loadpath;
  1444.     SCM oloadport = loadport;
  1445.     long olninum = scm_linum;
  1446.     SCM form, port;
  1447.     port = scm_open_file (filename,
  1448.               scm_makfromstr ("r", (sizet) sizeof (char), 0));
  1449.     if (FALSEP (port))
  1450.       return port;
  1451.     *scm_loc_loadpath = filename;
  1452.     loadport = port;
  1453.     scm_linum = 1;
  1454.     while (1)
  1455.       {
  1456.     form = scm_read (port, UNSPECIFIED);
  1457.     if (EOF_VAL == form)
  1458.       break;
  1459.     scm_eval_x (form);
  1460.       }
  1461.     scm_close_port (port);
  1462.     scm_linum = olninum;
  1463.     loadport = oloadport;
  1464.     *scm_loc_loadpath = oloadpath;
  1465.   }
  1466.   return BOOL_T;
  1467. }
  1468.  
  1469.  
  1470. /* {Way Out}
  1471.  */
  1472.  
  1473. PROC (s_quit, "quit", 0, 1, 0, scm_quit);
  1474. #ifdef __STDC__
  1475. SCM 
  1476. scm_quit (SCM n)
  1477. #else
  1478. SCM 
  1479. scm_quit (n)
  1480.      SCM n;
  1481. #endif
  1482. {
  1483.   if (UNBNDP (n) || BOOL_T == n)
  1484.     n = MAKINUM (EXIT_SUCCESS);
  1485.   else if (INUMP (n))
  1486.     scm_exitval = n;
  1487.   else
  1488.     scm_exitval = MAKINUM (EXIT_FAILURE);
  1489.   if (scm_errjmp_bad)
  1490.     exit (INUM (scm_exitval));
  1491.   scm_dowinds (EOL, scm_ilength (dynwinds));
  1492.   longjmp (JMPBUF (rootcont), -1);
  1493. }
  1494.  
  1495.  
  1496. PROC (s_abort, "abort", 0, 0, 0, scm_abort);
  1497. #ifdef __STDC__
  1498. SCM 
  1499. scm_abort (void)
  1500. #else
  1501. SCM 
  1502. scm_abort ()
  1503. #endif
  1504. {
  1505.   if (scm_errjmp_bad)
  1506.     exit (INUM (scm_exitval));
  1507.   scm_dowinds (EOL, scm_ilength (dynwinds));
  1508.   longjmp (JMPBUF (rootcont), -2);
  1509. }
  1510.  
  1511.  
  1512. PROC (s_restart, "restart", 0, 0, 0, scm_restart);
  1513. #ifdef __STDC__
  1514. SCM 
  1515. scm_restart (void)
  1516. #else
  1517. SCM 
  1518. scm_restart ()
  1519. #endif
  1520. {
  1521.   scm_dowinds (EOL, scm_ilength (dynwinds));
  1522.   longjmp (JMPBUF (rootcont), -3);
  1523. }
  1524.  
  1525.  
  1526. /* {call-with-dynamic-root}
  1527.  *
  1528.  * Suspending the current thread to evaluate a thunk on the
  1529.  * same C stack but in a new dynamic context.
  1530.  *
  1531.  * Calls to call-with-dynamic-root return exactly once (unless
  1532.  * the process is somehow exitted).
  1533.  */
  1534.  
  1535. SCM scm_exitval;        /* INUM with return value */
  1536. static int n_dynamic_roots = 0;
  1537.  
  1538. #ifdef __STDC__
  1539. static SCM 
  1540. _cwdr (SCM thunk, SCM a1, SCM args, SCM error_thunk, STACKITEM * stack_start)
  1541. #else
  1542. static SCM 
  1543. _cwdr (thunk, a1, args, error_thunk, stack_start)
  1544.      SCM thunk;
  1545.      SCM a1;
  1546.      SCM args;
  1547.      SCM error_thunk;
  1548.      STACKITEM * stack_start;
  1549. #endif
  1550. {
  1551. #ifdef _UNICOS
  1552.   int i;
  1553. #else
  1554.   long i;
  1555. #endif
  1556.  
  1557.   SCM inferior_exitval;        /* INUM with return value */
  1558.   SCM old_dynamic_winds;
  1559.   SCM old_rootcont;
  1560.   SCM answer;
  1561.  
  1562.   /* Exit the caller's dynamic state. 
  1563.    */
  1564.   old_dynamic_winds = dynwinds;
  1565.   scm_dowinds (EOL, scm_ilength (dynwinds));
  1566.  
  1567.   /* Create a fresh root continuation.
  1568.    * Temporarily substitute it for the native root continuation.
  1569.    */
  1570.   old_rootcont = rootcont;
  1571.   {
  1572.     SCM new_root;
  1573.     NEWCELL (new_root);
  1574.     DEFER_INTS;
  1575.     SETJMPBUF (new_root,
  1576.            scm_must_malloc ((long) sizeof (regs),
  1577.                 "inferior root continuation"));
  1578.     CAR (new_root) = tc7_contin;
  1579.     DYNENV (new_root) = EOL;
  1580.     BASE (new_root) = stack_start;
  1581.     SEQ (new_root) = n_dynamic_roots++;
  1582.     ALLOW_INTS;
  1583.     rootcont = new_root;
  1584.   }
  1585.  
  1586.  
  1587.   /* Establish a jump-buffer for returns to this dynamic root.
  1588.    */
  1589.   i = setjmp (JMPBUF (rootcont));
  1590.  
  1591.   switch ((int) i)
  1592.     {
  1593.     default:
  1594.       {
  1595.     /* An error condition.
  1596.      */
  1597.     char *name = scm_errmsgs[i - WNA].s_response;
  1598.     if (name)
  1599.       {
  1600.         SCM proc = CDR (scm_intern (name, (sizet) strlen (name)));
  1601.         if (NIMP (proc))
  1602.           scm_apply (proc, EOL, EOL);
  1603.       }
  1604.     if ((i = scm_errmsgs[i - WNA].parent_err))
  1605.       goto error_exit;
  1606.     def_err_response ();
  1607.     scm_errjmp_bad = 0;
  1608.     scm_alrm_deferred = 0;
  1609.     scm_sig_deferred = 0;
  1610.     scm_ints_disabled = 0;
  1611.     goto error_exit;
  1612.       }
  1613.  
  1614.     case 0:
  1615.       inferior_exitval = MAKINUM (EXIT_SUCCESS);
  1616.       scm_errjmp_bad = 0;
  1617.       errno = 0;
  1618.       scm_alrm_deferred = 0;
  1619.       scm_sig_deferred = 0;
  1620.       scm_ints_disabled = 0;
  1621.       scm_errjmp_bad = 0;
  1622.       scm_alrm_deferred = 0;
  1623.       scm_sig_deferred = 0;
  1624.       scm_ints_disabled = 0;
  1625.       *scm_loc_loadpath = BOOL_F;
  1626.       answer = scm_apply (thunk, a1, args);
  1627.       goto return_answer;
  1628.  
  1629.     case -2:
  1630.       /* (...fallthrough)
  1631.        *
  1632.        * Inferior executed (abort).
  1633.        *
  1634.        */
  1635.       scm_errjmp_bad = 0;
  1636.       scm_alrm_deferred = 0;
  1637.       scm_sig_deferred = 0;
  1638.       scm_ints_disabled = 0;
  1639.       /*
  1640.        * (...fallthrough)
  1641.        */
  1642.     case -1:
  1643.       /* 
  1644.        * Inferior executed (quit).
  1645.        *
  1646.        * (...fallthrough)
  1647.        */
  1648.     case -3:
  1649.       /* (...fallthrough)
  1650.        *
  1651.        * Inferior executed (restart).
  1652.        *
  1653.        * (...fallthrough)
  1654.        */
  1655.     error_exit:
  1656.       /*
  1657.        *
  1658.        * Inferior caused an error.
  1659.        *
  1660.        */
  1661.       *scm_loc_loadpath = BOOL_F;
  1662.       answer = scm_apply (error_thunk, scm_cons (MAKINUM (i), EOL), EOL);
  1663.       rootcont = old_rootcont;
  1664.       scm_dowinds (old_dynamic_winds,   - scm_ilength (old_dynamic_winds));
  1665.       return answer;
  1666.     }
  1667.  
  1668.  return_answer:
  1669.   rootcont = old_rootcont;
  1670.   scm_dowinds (old_dynamic_winds,   - scm_ilength (old_dynamic_winds));
  1671.   return answer;
  1672. }
  1673.  
  1674.  
  1675. PROC (s_with_dynamic_root, "with-dynamic-root", 2, 0, 0, scm_with_dynamic_root);
  1676. #ifdef __STDC__
  1677. SCM
  1678. scm_with_dynamic_root (SCM thunk, SCM error_thunk)
  1679. #else
  1680. SCM
  1681. scm_with_dynamic_root (thunk, error_thunk)
  1682.      SCM thunk;
  1683.      SCM error_thunk;
  1684. #endif
  1685. {
  1686.   STACKITEM stack_place;
  1687.  
  1688.   return _cwdr (thunk, EOL, EOL, error_thunk, &stack_place);
  1689. }
  1690.  
  1691. #ifdef __STDC__
  1692. SCM
  1693. scm_app_wdr (SCM proc, SCM a1, SCM args, SCM error)
  1694. #else
  1695. SCM
  1696. scm_app_wdr (proc, a1, args, error)
  1697.      SCM proc;
  1698.      SCM a1;
  1699.      SCM args;
  1700.      SCM error;
  1701. #endif
  1702. {
  1703.   STACKITEM stack_place;
  1704.   return _cwdr (proc, a1, args, error, &stack_place);
  1705. }
  1706.  
  1707.  
  1708.  
  1709. /* {Read-eval-print Loops}
  1710.  */
  1711.  
  1712. int scm_verbose = 1;
  1713. long scm_cells_allocated = 0;
  1714. long scm_lcells_allocated = 0;
  1715. long scm_mallocated = 0;
  1716. long scm_lmallocated = 0;
  1717. long scm_rt = 0;
  1718. long scm_gc_rt;
  1719. long scm_gc_time_taken;
  1720. long scm_gc_cells_collected;
  1721. long scm_gc_malloc_collected;
  1722. long scm_gc_ports_collected;
  1723.  
  1724.  
  1725. #ifdef __STDC__
  1726. int
  1727. scm_ldfile(char *path)
  1728. #else
  1729. int
  1730. scm_ldfile(path)
  1731.      char *path;
  1732. #endif
  1733. {
  1734.   SCM name = scm_makfromstr(path, (sizet)(strlen(path))*sizeof(char), 0);
  1735.   *scm_loc_errobj = name;
  1736.   return BOOL_F==scm_try_load(name);
  1737. }
  1738.  
  1739.  
  1740. #ifdef __STDC__
  1741. int
  1742. scm_ldprog(char *path)
  1743. #else
  1744. int
  1745. scm_ldprog(path)
  1746.      char *path;
  1747. #endif
  1748. {
  1749.   SCM name = scm_makfromstr(path, (sizet)(strlen(path))*sizeof(char), 0);
  1750.   *scm_loc_errobj = name;
  1751.   return
  1752.     BOOL_F==scm_evstr("(try-load (in-vicinity (program-vicinity) errobj))");
  1753. }
  1754.  
  1755.  
  1756. PROC (s_eval_string, "eval-string", 1, 0, 0, scm_eval_string);
  1757. #ifdef __STDC__
  1758. SCM
  1759. scm_eval_string(SCM str)
  1760. #else
  1761. SCM
  1762. scm_eval_string(str)
  1763.      SCM str;
  1764. #endif
  1765. {
  1766.   str = scm_mkstrport(INUM0, str, OPN | RDNG, s_eval_string);
  1767.   str = scm_read(str, default_case_i);
  1768.   return EVAL(str, (SCM)EOL);
  1769. }
  1770.  
  1771.  
  1772. #ifdef __STDC__
  1773. SCM
  1774. scm_evstr(char *str)
  1775. #else
  1776. SCM
  1777. scm_evstr(str)
  1778.      char *str;
  1779. #endif
  1780. {
  1781.   SCM lsym;
  1782.   NEWCELL(lsym);
  1783.   SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
  1784.   SETCHARS(lsym, str);
  1785.   return scm_eval_string(lsym);
  1786. }
  1787.  
  1788.  
  1789. PROC (s_load_string, "load-string", 1, 0, 0, scm_load_string);
  1790. #ifdef __STDC__
  1791. SCM
  1792. scm_load_string(SCM str)
  1793. #else
  1794. SCM
  1795. scm_load_string(str)
  1796.      SCM str;
  1797. #endif
  1798. {
  1799.   ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1,
  1800.      s_load_string);
  1801.   str = scm_mkstrport(INUM0, str, OPN | RDNG, s_load_string);
  1802.   while(1) {
  1803.     SCM form = scm_read(str, default_case_i);
  1804.     if (EOF_VAL==form) break;
  1805.     SIDEVAL(form, EOL);
  1806.   }
  1807.   return BOOL_T;
  1808. }
  1809.  
  1810.  
  1811. #ifdef __STDC__
  1812. void
  1813. scm_ldstr(char *str)
  1814. #else
  1815. void
  1816. scm_ldstr(str)
  1817.      char *str;
  1818. #endif
  1819. {
  1820.   SCM lsym;
  1821.   NEWCELL(lsym);
  1822.   SETLENGTH(lsym, strlen(str)+0L, tc7_ssymbol);
  1823.   SETCHARS(lsym, str);
  1824.   scm_load_string(lsym);
  1825. }
  1826.  
  1827. SCM scm_exitval;        /* INUM with return value */
  1828. #ifdef __STDC__
  1829. SCM 
  1830. scm_repl_driver (char *initpath)
  1831. #else
  1832. SCM 
  1833. scm_repl_driver (initpath)
  1834.      char *initpath;
  1835. #endif
  1836. {
  1837. #ifdef _UNICOS
  1838.   int i;
  1839. #else
  1840.   long i;
  1841. #endif
  1842.   BASE (rootcont) = (STACKITEM *) & i;
  1843.   SEQ (rootcont) = n_dynamic_roots++;
  1844.   i = setjmp (JMPBUF (rootcont));
  1845. drloop:
  1846.   switch ((int) i)
  1847.     {
  1848.     default:
  1849.       {
  1850.     char *name = scm_errmsgs[i - WNA].s_response;
  1851.     if (name)
  1852.       {
  1853.         SCM proc = CDR (scm_intern (name, (sizet) strlen (name)));
  1854.         if (NIMP (proc))
  1855.           scm_apply (proc, EOL, EOL);
  1856.       }
  1857.     if ((i = scm_errmsgs[i - WNA].parent_err))
  1858.       goto drloop;
  1859.     def_err_response ();
  1860.     goto reset_toplvl;
  1861.       }
  1862.     case 0:
  1863.       scm_exitval = MAKINUM (EXIT_SUCCESS);
  1864.       scm_errjmp_bad = 0;
  1865.       errno = 0;
  1866.       scm_alrm_deferred = 0;
  1867.       scm_sig_deferred = 0;
  1868.       scm_ints_disabled = 0;
  1869.       if (scm_ldfile(initpath))    /* load Scheme init files */
  1870.     scm_wta(*scm_loc_errobj, "Could not open file", s_load); /*  */
  1871.     case -2:
  1872.     reset_toplvl:
  1873.       scm_errjmp_bad = 0;
  1874.       scm_alrm_deferred = 0;
  1875.       scm_sig_deferred = 0;
  1876.       scm_ints_disabled = 0;
  1877.       /* need to close loading files here. */
  1878.       *scm_loc_loadpath = BOOL_F;
  1879.       loadport = SCM_UNDEFINED;
  1880.       scm_repl (scm_makfromstr (PROMPT, strlen (PROMPT), 0), BOOL_F);
  1881.       scm_err_pos = (char *) EXIT;
  1882.       i = EXIT;
  1883.       goto drloop;        /* encountered EOF on stdin */
  1884.     case -1:
  1885.       return scm_exitval;
  1886.     case -3:
  1887.       return 0;
  1888.     }
  1889. }
  1890.  
  1891.  
  1892. PROC (s_line_number, "line-number", 0, 0, 0, scm_line_number);
  1893. #ifdef __STDC__
  1894. SCM 
  1895. scm_line_number (void)
  1896. #else
  1897. SCM 
  1898. scm_line_number ()
  1899. #endif
  1900. {
  1901.   return MAKINUM (scm_linum);
  1902. }
  1903.  
  1904.  
  1905.  
  1906. PROC (s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments);
  1907. #ifdef __STDC__
  1908. SCM 
  1909. scm_program_arguments (void)
  1910. #else
  1911. SCM 
  1912. scm_program_arguments ()
  1913. #endif
  1914. {
  1915.   return progargs;
  1916. }
  1917.  
  1918. extern char s_heap[];
  1919. extern CELLPTR *scm_hplims;
  1920. #ifdef __STDC__
  1921. void 
  1922. scm_growth_mon (char *obj, long size, char *units)
  1923. #else
  1924. void 
  1925. scm_growth_mon (obj, size, units)
  1926.      char *obj;
  1927.      long size;
  1928.      char *units;
  1929. #endif
  1930. {
  1931.   if (scm_verbose > 2)
  1932.     {
  1933.       scm_puts ("; grew ", cur_errp);
  1934.       scm_puts (obj, cur_errp);
  1935.       scm_puts (" to ", cur_errp);
  1936.       scm_intprint (size, 10, cur_errp);
  1937.       scm_putc (' ', cur_errp);
  1938.       scm_puts (units, cur_errp);
  1939.       if ((scm_verbose > 4) && !strcmp (obj, "heap"))
  1940.     scm_heap_report ();
  1941.       scm_puts ("\n", cur_errp);
  1942.     }
  1943. }
  1944.  
  1945. #ifdef __STDC__
  1946. void 
  1947. scm_gc_start (char *what)
  1948. #else
  1949. void 
  1950. scm_gc_start (what)
  1951.      char *what;
  1952. #endif
  1953. {
  1954.   if (scm_verbose > 3 && FPORTP (cur_errp))
  1955.     {
  1956.       ALLOW_INTS;
  1957.       scm_puts (";GC(", cur_errp);
  1958.       scm_puts (what, cur_errp);
  1959.       scm_puts (")", cur_errp);
  1960.       scm_fflush (cur_errp);
  1961.       DEFER_INTS;
  1962.     }
  1963.   scm_gc_rt = INUM (scm_my_time ());
  1964.   scm_gc_cells_collected = 0;
  1965.   scm_gc_malloc_collected = 0;
  1966.   scm_gc_ports_collected = 0;
  1967. }
  1968.  
  1969. #ifdef __STDC__
  1970. void 
  1971. scm_gc_end (void)
  1972. #else
  1973. void 
  1974. scm_gc_end ()
  1975. #endif
  1976. {
  1977.   scm_gc_rt = INUM (scm_my_time ()) - scm_gc_rt;
  1978.   scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt;
  1979.   if (scm_verbose > 3)
  1980.     {
  1981.       ALLOW_INTS;
  1982.       if (!FPORTP (cur_errp))
  1983.     scm_puts (";GC ", cur_errp);
  1984.       scm_intprint (scm_time_in_msec (scm_gc_rt), 10, cur_errp);
  1985.       scm_puts (" cpu mSec, ", cur_errp);
  1986.       scm_intprint (scm_gc_cells_collected, 10, cur_errp);
  1987.       scm_puts (" cells, ", cur_errp);
  1988.       scm_intprint (scm_gc_malloc_collected, 10, cur_errp);
  1989.       scm_puts (" malloc, ", cur_errp);
  1990.       scm_intprint (scm_gc_ports_collected, 10, cur_errp);
  1991.       scm_puts (" ports collected\n", cur_errp);
  1992.       scm_fflush (cur_errp);
  1993.       DEFER_INTS;
  1994.     }
  1995. }
  1996.  
  1997. #ifdef __STDC__
  1998. void
  1999. scm_repl_report (void)
  2000. #else
  2001. void
  2002. scm_repl_report ()
  2003. #endif
  2004. {
  2005.   if (scm_verbose > 1)
  2006.     {
  2007.       scm_fflush (cur_outp);
  2008.       scm_puts (";Evaluation took ", cur_errp);
  2009.       scm_intprint (scm_time_in_msec (INUM (scm_my_time ()) - scm_rt), 10, cur_errp);
  2010.       scm_puts (" mSec (", cur_errp);
  2011.       scm_intprint (scm_time_in_msec (scm_gc_time_taken), 10, cur_errp);
  2012.       scm_puts (" in scm_gc) ", cur_errp);
  2013.       scm_intprint (scm_cells_allocated - scm_lcells_allocated, 10, cur_errp);
  2014.       scm_puts (" cells work, ", cur_errp);
  2015.       scm_intprint (scm_mallocated - scm_lmallocated, 10, cur_errp);
  2016.       scm_puts (" bytes other\n", cur_errp);
  2017.       scm_fflush (cur_errp);
  2018.     }
  2019. }
  2020.  
  2021. PROC (s_room, "room", 1, 0, 0, scm_room);
  2022. #ifdef __STDC__
  2023. SCM 
  2024. scm_room (SCM args)
  2025. #else
  2026. SCM 
  2027. scm_room (args)
  2028.      SCM args;
  2029. #endif
  2030. {
  2031.   scm_intprint (scm_cells_allocated, 10, cur_errp);
  2032.   scm_puts (" out of ", cur_errp);
  2033.   scm_intprint (scm_heap_size, 10, cur_errp);
  2034.   scm_puts (" cells in use, ", cur_errp);
  2035.   scm_intprint (scm_mallocated, 10, cur_errp);
  2036.   scm_puts (" bytes allocated (of ", cur_errp);
  2037.   scm_intprint (scm_mtrigger, 10, cur_errp);
  2038.   scm_puts (")\n", cur_errp);
  2039.   if (NIMP (args))
  2040.     {
  2041.       scm_heap_report ();
  2042.       scm_puts ("\n", cur_errp);
  2043.       scm_stack_report ();
  2044.     }
  2045.   return UNSPECIFIED;
  2046. }
  2047.  
  2048. extern int scm_n_heap_segs;
  2049. #ifdef __STDC__
  2050. void 
  2051. scm_heap_report (void)
  2052. #else
  2053. void 
  2054. scm_heap_report ()
  2055. #endif
  2056. {
  2057.   sizet i = 0;
  2058.   scm_puts ("; heap segments:", cur_errp);
  2059.   while (i < scm_n_heap_segs)
  2060.     {
  2061.       scm_puts ("\n; 0x", cur_errp);
  2062.       scm_intprint ((long) scm_heap_table[i].bounds[0], 16, cur_errp);
  2063.       scm_puts (" - 0x", cur_errp);
  2064.       scm_intprint ((long) scm_heap_table[i].bounds[1], 16, cur_errp);
  2065.       ++i;
  2066.     }
  2067. }
  2068.  
  2069. #ifdef __STDC__
  2070. void 
  2071. scm_exit_report (void)
  2072. #else
  2073. void 
  2074. scm_exit_report ()
  2075. #endif
  2076. {
  2077.   if (scm_verbose > 2)
  2078.     {
  2079.       scm_puts (";Totals: ", cur_errp);
  2080.       scm_intprint (scm_time_in_msec (INUM (scm_my_time ())), 10, cur_errp);
  2081.       scm_puts (" mSec my time, ", cur_errp);
  2082.       scm_intprint (scm_time_in_msec (INUM (scm_your_time ())), 10, cur_errp);
  2083.       scm_puts (" mSec your time\n", cur_errp);
  2084.     }
  2085. }
  2086.  
  2087.  
  2088. PROC (s_verbose, "verbose", 0, 1, 0, scm_prolixity);
  2089. #ifdef __STDC__
  2090. SCM 
  2091. scm_prolixity (SCM arg)
  2092. #else
  2093. SCM 
  2094. scm_prolixity (arg)
  2095.      SCM arg;
  2096. #endif
  2097. {
  2098.   int old = scm_verbose;
  2099.   if (!UNBNDP (arg))
  2100.     {
  2101.       if (FALSEP (arg))
  2102.     scm_verbose = 1;
  2103.       else
  2104.     scm_verbose = INUM (arg);
  2105.     }
  2106.   return MAKINUM (old);
  2107. }
  2108.  
  2109. PROC (s_repl, "repl", 1, 1, 0, scm_repl);
  2110. #ifdef __STDC__
  2111. SCM
  2112. scm_repl (SCM prompt, SCM env)
  2113. #else
  2114. SCM
  2115. scm_repl (prompt, env)
  2116.      SCM prompt;
  2117.      SCM env;
  2118. #endif
  2119. {
  2120.   SCM x;
  2121.   SCM answer;
  2122.   scm_repl_report ();
  2123.   answer = BOOL_F;
  2124.   while (1)
  2125.     {
  2126.       if (OPOUTPORTP (cur_inp))
  2127.  
  2128.     {            /* This case for curses window */
  2129.       scm_fflush (cur_outp);
  2130.       if (scm_verbose)
  2131.         scm_puts (CHARS (prompt), cur_inp);
  2132.       scm_fflush (cur_inp);
  2133.     }
  2134.       else
  2135.     {
  2136.       if (scm_verbose >= 0)
  2137.         scm_puts (CHARS (prompt), cur_outp);
  2138.       scm_fflush (cur_outp);
  2139.     }
  2140.       scm_lcells_allocated = scm_cells_allocated;
  2141.       scm_lmallocated = scm_mallocated;
  2142.       x = scm_read (cur_inp, UNSPECIFIED);
  2143.       scm_rt = INUM (scm_my_time ());
  2144.       scm_gc_time_taken = 0;
  2145.       if (EOF_VAL == x)
  2146.     break;
  2147.       if (!CRDYP (cur_inp))    /* assure scm_newline read (and transcripted) */
  2148.     scm_lungetc (scm_lgetc (cur_inp), cur_inp);
  2149. #ifdef __TURBOC__
  2150.       if ('\n' != CGETUN (cur_inp))
  2151.     if (OPOUTPORTP (cur_inp))
  2152.         /* This case for curses window */
  2153.       {
  2154.         scm_fflush (cur_outp);
  2155.         scm_newline (cur_inp);
  2156.       }
  2157.     else
  2158.       scm_newline (cur_outp);
  2159. #endif
  2160.       {
  2161.     SCM top_env;
  2162.     top_env = (env == BOOL_F
  2163.            ? scm_top_level_env (CDR (scm_top_level_lookup_thunk_var))
  2164.            : env);
  2165.     answer = x = scm_eval_3 (x, 0, top_env);
  2166.       }
  2167.       scm_repl_report ();
  2168.       if (scm_verbose >= 0)
  2169.     {
  2170.       scm_iprin1 (x, cur_outp, 1);
  2171.       scm_putc ('\n', cur_outp);
  2172.     }
  2173.     }
  2174.   return answer;
  2175. }
  2176.  
  2177. /* {Standard Ports}
  2178.  */
  2179. PROC (s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port);
  2180. #ifdef __STDC__
  2181. SCM 
  2182. scm_current_input_port (void)
  2183. #else
  2184. SCM 
  2185. scm_current_input_port ()
  2186. #endif
  2187. {
  2188.   return cur_inp;
  2189. }
  2190.  
  2191. PROC (s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port);
  2192. #ifdef __STDC__
  2193. SCM 
  2194. scm_current_output_port (void)
  2195. #else
  2196. SCM 
  2197. scm_current_output_port ()
  2198. #endif
  2199. {
  2200.   return cur_outp;
  2201. }
  2202.  
  2203. PROC (s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port);
  2204. #ifdef __STDC__
  2205. SCM 
  2206. scm_current_error_port (void)
  2207. #else
  2208. SCM 
  2209. scm_current_error_port ()
  2210. #endif
  2211. {
  2212.   return cur_errp;
  2213. }
  2214.  
  2215. PROC (s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port);
  2216. #ifdef __STDC__
  2217. SCM 
  2218. scm_set_current_input_port (SCM port)
  2219. #else
  2220. SCM 
  2221. scm_set_current_input_port (port)
  2222.      SCM port;
  2223. #endif
  2224. {
  2225.   SCM oinp = cur_inp;
  2226.   ASSERT (NIMP (port) && OPINPORTP (port), port, ARG1, s_current_error_port);
  2227.   cur_inp = port;
  2228.   return oinp;
  2229. }
  2230.  
  2231.  
  2232. PROC (s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port);
  2233. #ifdef __STDC__
  2234. SCM 
  2235. scm_set_current_output_port (SCM port)
  2236. #else
  2237. SCM 
  2238. scm_set_current_output_port (port)
  2239.      SCM port;
  2240. #endif
  2241. {
  2242.   SCM ooutp = cur_outp;
  2243.   ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, s_current_error_port);
  2244.   cur_outp = port;
  2245.   return ooutp;
  2246. }
  2247.  
  2248.  
  2249. PROC (s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port);
  2250. #ifdef __STDC__
  2251. SCM 
  2252. scm_set_current_error_port (SCM port)
  2253. #else
  2254. SCM 
  2255. scm_set_current_error_port (port)
  2256.      SCM port;
  2257. #endif
  2258. {
  2259.   SCM oerrp = cur_errp;
  2260.   ASSERT (NIMP (port) && OPOUTPORTP (port), port, ARG1, s_current_error_port);
  2261.   cur_errp = port;
  2262.   return oerrp;
  2263. }
  2264.  
  2265. /* {Help finding slib}
  2266.  */
  2267.  
  2268.  
  2269. PROC (s_compiled_library_path, "compiled-library-path", 0, 0, 0, scm_compiled_library_path);
  2270. #ifdef __STDC__
  2271. SCM
  2272. scm_compiled_library_path (void)
  2273. #else
  2274. SCM
  2275. scm_compiled_library_path ()
  2276. #endif
  2277. {
  2278. #ifndef LIBRARY_PATH
  2279.   return BOOL_F;
  2280. #else
  2281.   return makfrom0str (LIBRARY_PATH);
  2282. #endif
  2283. }
  2284.  
  2285.  
  2286.  
  2287. /* {Initializing the Module}
  2288.  */
  2289.  
  2290.  
  2291. char s_ccl[] = "char-code-limit";
  2292.  
  2293. #ifdef __STDC__
  2294. void
  2295. scm_final_repl (void)
  2296. #else
  2297. void
  2298. scm_final_repl ()
  2299. #endif
  2300. {
  2301.   scm_loc_errobj = (SCM *) & scm_tmp_errobj;
  2302.   scm_loc_loadpath = (SCM *) & scm_tmp_loadpath;
  2303.   loadport = SCM_UNDEFINED;
  2304.   transcript = BOOL_F;
  2305.   scm_trans = 0;
  2306.   scm_linum = 1;
  2307. }
  2308.  
  2309.  
  2310.  
  2311. #ifdef __STDC__
  2312. void
  2313. scm_init_repl (int iverbose)
  2314. #else
  2315. void
  2316. scm_init_repl (iverbose)
  2317.      int iverbose;
  2318. #endif
  2319. {
  2320.   scm_sysintern (s_ccl, MAKINUM (CHAR_CODE_LIMIT));
  2321.   scm_loc_errobj = &CDR (scm_sysintern ("errobj", SCM_UNDEFINED));
  2322.   scm_loc_loadpath = &CDR (scm_sysintern ("*load-pathname*", BOOL_F));
  2323.   transcript = BOOL_F;
  2324.   scm_trans = 0;
  2325.   scm_linum = 1;
  2326.   scm_verbose = iverbose;
  2327. #ifndef GO32
  2328.   scm_add_feature(s_char_ready_p);
  2329. #endif
  2330. #ifdef ARM_ULIB
  2331.   set_erase ();
  2332. #endif
  2333.   system_error_sym = CAR (scm_intern0 ("%%system-error"));
  2334.   scm_permenant_object (system_error_sym);
  2335. #include "repl.x"
  2336. }
  2337.  
  2338.